home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BBS Toolkit
/
BBS Toolkit.iso
/
rbbs_pc
/
173amrg.zip
/
RSB1173A.MRG
< prev
next >
Wrap
Text File
|
1990-08-26
|
11KB
|
306 lines
* ------------[ BLED merge (c) Ken Goosens ]-------------
* Merge this against D:\172B\RBBSSUB1.BAS to produce RBBSSUB1.BAS
* D:\172B\RBBSSUB1.BAS: Date 2-10-1990 Size 53454 bytes
* ------------[ Created 08-26-1990 11:28:06 ]------------
* REPLACING old line(s) by new
' $linesize:132
* ------[ first line different ]------
' $title: 'RBBS-SUB1.BAS 17.3A, Copyright 1986-90 by D. Thomas Mack' ' DA081003
' Copyright 1990 by D. Thomas Mack, all rights reserved.
' Name ...............: RBBSSUB1.BAS
' First Released .....: February 11, 1990
' Subsequent Releases.: August 26, 1990
' Copyright ..........: 1986-1990
' Purpose.............:
' Subprorams that require error trapping are incorporated
' within RBBSSUB1.BAS as separately callable subroutines
' in order to free up as much code as possible within
' the 64WasK code segment used by RBBS-PC.BAS.
' Parameters..........: Most parameters are passed via a COMMON statement.
'
' Subroutine Line Function of Subroutine
' Name Number
' ChangeDir 20101 Change subdirectory
' CheckInt 58360 Check input is valid integer
' CommPut 59275 Write string to communications port
' FindFile 59790 Determine whether a file exists without opening it
' FindFree 51098 Find amount of space on the upload disk drive
' FindItX 20219 Find if a file exists on a device
' FindUser 12598 Find a user in the USERS file
' FlushCom 20308 Read all characters in the communications port
' GetCom 1418 Read a character from the communications port
' GetPassword 58280 Read RBBS-PC's "PASSWORD" file
' GETWRK 58330 Read record from file number 2
' KillWork 58258 Delete a RBBS-PC "WORK" file
' NetBIOS 20898 Lock/Unlock NetBIOS semaphore files
' OpenCom 200 Open communications port (number 3)
' OpenFMS 58188 Open the upload management system directory
' OpenOutW 28218 Open RBBS-PC's "WORK" file (number 2) for output
' OpenRSeq 1479 Open a sequential file (number 2) for random I/O
' OpenUser 9398 Open the USER file (number 5)
' OpenWork 57978 Open RBBS-PC's work file (number 2)
' OpenWorkA 58340 Open RBBS-PC's "WORK" file (number 2) for append
' Printit 13673 Print line on the local PC printer
' PrintWork 58320 Print string to file #2 w/o CR/LF
' PrintWorkA 58350 Print string to file #2 with CR/LF
' PutCom 59650 Write to the communications port
' PutWork 59660 Write to work file randomly
' RBBSPlay 59680 Plays a musical string
' ReadAny 58310 Read file number 2 into ZOutTxt$
' ReadDef 112 Read configuration file
' ReadDir 58290 Read entire lines
' ReadParms 58300 Read certain number of parameters from file 2
' Talk 59700 RBBS-PC Voice synthesizer support for sight impaired
' SetCall 108 Find where next callers record is
' UpdateC 43048 Update the caller's file with elasped session time
' UpdtCalr 13661 Update to the caller's file
'
' $INCLUDE: 'RBBS-VAR.BAS'
'
* REPLACING old line(s) by new
108 ' $SUBTITLE: 'SetCall - subroutine to find last callers rec'
' $PAGE
'
' NAME -- SetCall
'
' INPUTS -- PARAMETER MEANING
'
' OUTPUTS -- ZCallersFileIndex!
'
' PURPOSE -- To find where to leave off on callers file
'
SUB SetCall STATIC
ON ERROR GOTO 65000
* ------[ first line different ]------
IF ZPrevCaller$ = ZCallersFile$ OR ZCallersFilePrefix$ = "" THEN _ ' KG052401
EXIT SUB
ZPrevCaller$ = ZCallersFile$ ' KG052401
ZCallersFileIndex! = 1
CLOSE 2
CLOSE 4
IF ZShareIt THEN _
OPEN ZCallersFile$ FOR RANDOM SHARED AS #4 LEN=64 _
ELSE OPEN "R",4,ZCallersFile$,64
FIELD 4,64 AS ZCallersRecord$
IF LOF(4) > 0 THEN _
ZCallersFileIndex! = LOF(4) / 64
IF ZCallersFileIndex! < 1 THEN _
ZCallersFileIndex! = 0
ZUserIn$ = STRING$(13,0)
* REPLACING old line(s) by new
110 GET 4,ZCallersFileIndex!
IF ZErrCode > 0 THEN _
ZErrCode = 0 : _
ZCallersFileIndex! = 0 : _
EXIT SUB
IF LEFT$(ZCallersRecord$,13) = ZUserIn$ THEN _
ZCallersFileIndex! = ZCallersFileIndex! - 1 : _
GOTO 110
END SUB
* ------[ first line different ]------
* REPLACING old line(s) by new
12600 ZWasY$ = IndivToLookFor$ + SPACE$(LenIndivField - LEN(IndivToLookFor$))
PosToReclaim = 0
* ------[ first line different ]------
ZErrCode = 0 ' KG061001
* REPLACING old line(s) by new
12610 GET 5,PosToUse
IF ZErrCode > 0 THEN _
IF ZErrCode = 63 THEN _
ZErrCode = 0 : _
GOTO 12621 _
ELSE ZErrCode = 0 : _
* ------[ first line different ]------
GOTO 12620 ' KG061001
HashValue$ = MID$(Filler$,StartHashPos,LenHashField)
IF WasX$ = HashValue$ THEN _
IF StartIndivPos < 1 THEN _
WhetherFound = ZTrue : _ ' KG061001
GOTO 12622 _ ' KG061001
ELSE IndivValue$ = MID$(Filler$,StartIndivPos,LenIndivField) : _
IF ZWasY$ = IndivValue$ OR IndivValue$ = EmptyIndiv$ THEN _
WhetherFound = ZTrue : _
GOTO 12622
IF HashValue$ = EmptyRec$ THEN _
PosToUse = PosToReclaim - (PosToReclaim = 0) * PosToUse : _
WhetherFound = ZFalse : _
GOTO 12622
IF ASC(HashValue$) = 0 OR INSTR(HashValue$,NewUser$) = 1 THEN _
IF PosToReclaim = 0 THEN _
PosToReclaim = PosToUse
* REPLACING old line(s) by new
13670 LSET ZCallersRecord$ = WasX$
* ------[ first line different ]------
CALL Printit (ZCallersRecord$) ' KG052702
ZCallersFileIndex! = ZCallersFileIndex! + 1
* REPLACING old line(s) by new
29920 ZErrCode = 0
IF IBMFileLock = 6 AND IBMRecLock = 3 THEN _
IBMCount = IBMCount - 1 : _
IF IBMCount > 0 THEN _
EXIT SUB _
ELSE IBMCount = 0
UNLOCK IBMFileLock, IBMRecLock TO IBMRecLock
* ------[ first line different ]------
IF ZErrCode = 70 THEN _ ' ML041401
EXIT SUB ' ML041401
IF ZErrCode <> 0 THEN _
GOTO 29920
END SUB
* REPLACING old line(s) by new
65000 IF ZDebug THEN _
ZOutTxt$ = "RBBSSUB1 DEBUG Error Trap Entry ERL=" + _
STR$(ERL) + _
" ERR=" + _
STR$(ERR) : _
IF ZPrinter THEN _
CALL Printit(ZOutTxt$) _
ELSE CALL LPrnt(ZOutTxt$,1)
ZErrCode = ERR
'
' SetCall
'
* ------[ first line different ]------
IF ERL = 108 THEN _
CALL PScrn ("Unable to create callers log " + ZCallersFile$) : _ ' KG081602
SYSTEM ' KG081602
IF ERL = 110 THEN _
RESUME NEXT
'
' OPEN CONFIG FILE
'
IF ERL => 117 AND ERL <= 119 THEN _
RESUME NEXT
'
' OPEN COM PORT ERROR HANDLING
'
IF ERL = 200 THEN _
CLS : _
CALL PScrn (ZComPort$ + " does not exist/not responding- Error" + STR$(ERR)) : _
STOP
'
' GetCom ERROR HANDLING
'
IF ERL = 1420 AND ERR = 57 THEN _
RESUME NEXT
IF ERL = 1420 AND ERR = 69 THEN _
ZSubParm = -1 :_
RESUME NEXT
'
' OPENRESEQ ERROR HANDLING
'
IF ERL = 1481 THEN _
ZErrCode = ERR : _
RESUME NEXT
'
' OpenUser ERROR HANDLING
'
IF ERL = 9400 AND ERR = 75 AND ZShareIt THEN _
CALL DelayTime (30) : _
RESUME
'
' FindUser ERROR HANDLING
'
IF ERL = 12610 OR ERL = 12600 THEN _ ' KG061001
RESUME NEXT
'
' UpdtCalr ERROR HANDLING
'
IF ERL = 13663 THEN _
RESUME NEXT
IF ERL = 13672 AND ERR = 61 THEN _
CALL QuickTPut1 ("Disk Full") : _
IF ZDiskFullGoOffline THEN _
GOTO 65010 _
ELSE RESUME NEXT
IF ERL = 13672 THEN _
ZCallersFileIndex! = ZCallersFileIndex! - 1 : _
RESUME NEXT
'
' ZPrinter ERROR HANDLING
'
IF ERL = 13674 THEN _
ZPrinter = ZFalse : _
RESUME
'
' ChangeDir ERROR HANDLING
'
IF ERL = 20103 THEN _
ZOK = ZFalse : _
RESUME NEXT
'
' FindIt ERROR HANDLING
'
IF ERL = 20221 THEN _
RESUME NEXT
IF ERL = 20223 AND ZErrCode = 58 THEN _
ZErrCode = 64 : _
ZOK = ZFalse : _
RESUME NEXT
IF ERL = 20223 AND ZErrCode = 76 THEN _
CALL LPrnt("Bad path. File name is " + FilName$,1) : _
ZErrCode = 76 : _
ZOK = ZFalse : _
RESUME NEXT
IF ERL => 20221 AND ERL <= 20223 AND ZErrCode = 70 _
AND ZNetworkType = 6 THEN _
ZErrCode = 0 : _
RESUME NEXT
IF ERL => 20221 AND ERL <= 20223 THEN _
RESUME
'
' FlushCom ERROR HANDLING
'
IF ERL = 20311 AND ERR = 57 THEN _
RESUME NEXT
IF ERL = 20311 AND ERR = 69 THEN _
ZAbort = ZTrue : _
ZSubParm = -1 : _
RESUME NEXT
'
' NetBIOS ERROR HANDLING
'
IF ERL => 29900 AND ERL <= 29920 THEN _
RESUME NEXT
'
' UpdateC ERROR HANDLING
'
IF ERL => 43050 AND ERL <= 43060 AND ERR = 61 THEN _
ZOutTxt$ = "* Disk full - terminating *" : _
ZSubParm =2 : _
CALL TPut : _
IF ZDiskFullGoOffline THEN _
GOTO 65010 _
ELSE SYSTEM
'
' CheckInt ERROR HANDLING
'
IF (ERL = 59652 OR ERL = 59727) AND ERR = 24 THEN _
ZNotCTS = ZTrue : _
CALL Line25 : _
ZErrCode = 0 : _
RESUME
IF ERL => 52000 AND ERL <= 59725 THEN _
RESUME NEXT
'
' FindFile ERROR HANDLING
'
IF ERL = 59791 THEN _
IF ERR = 57 THEN _
CALL DelayTime (1) : _
CALL UpdtCalr ("SLOW I/O ERROR",1) : _
IOErrorCount = IOErrorCount + 1 : _
IF IOErrorCount < 11 THEN _
RESUME
'
' CATCH ALL OTHER ERRORS
'
ZOutTxt$ = "RBBS-SUB1 Untrapped Error" + _
STR$(ERR) + _
" in line" + _
STR$(ERL)
CALL QuickTPut1 (ZOutTxt$)
CALL UpdtCalr (ZOutTxt$,2)
RESUME NEXT
' SHARED ROUTINE FOR GOING OFF LINE WHEN DISK FULL